home *** CD-ROM | disk | FTP | other *** search
/ Complete Internet Archive / Complete Internet Archive.iso / VRML / cp2b2x.exe / DATA.Z / tearoff.tcl < prev    next >
Text File  |  1996-04-23  |  4KB  |  130 lines
  1. # tearoff.tcl --
  2. #
  3. # This file contains procedures that implement tear-off menus.
  4. #
  5. # @(#) tearoff.tcl 1.7 95/08/30 09:11:52
  6. #
  7. # Copyright (c) 1994 The Regents of the University of California.
  8. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14. # tkTearoffMenu --
  15. # Given the name of a menu, this procedure creates a torn-off menu
  16. # that is identical to the given menu (including nested submenus).
  17. # The new torn-off menu exists as a toplevel window managed by the
  18. # window manager.  The return value is the name of the new menu.
  19. #
  20. # Arguments:
  21. # w -            The menu to be torn-off (duplicated).
  22.  
  23. proc tkTearOffMenu w {
  24.     # Find a unique name to use for the torn-off menu.  Find the first
  25.     # ancestor of w that is a toplevel but not a menu, and use this as
  26.     # the parent of the new menu.  This guarantees that the torn off
  27.     # menu will be on the same screen as the original menu.  By making
  28.     # it a child of the ancestor, rather than a child of the menu, it
  29.     # can continue to live even if the menu is deleted;  it will go
  30.     # away when the toplevel goes away.
  31.  
  32.     set parent [winfo parent $w]
  33.     while {([winfo toplevel $parent] != $parent)
  34.         || ([winfo class $parent] == "Menu")} {
  35.     set parent [winfo parent $parent]
  36.     }
  37.     if {$parent == "."} {
  38.     set parent ""
  39.     }
  40.     for {set i 1} 1 {incr i} {
  41.     set menu $parent.tearoff$i
  42.     if ![winfo exists $menu] {
  43.         break
  44.     }
  45.     }
  46.  
  47.     tkMenuDup $w $menu
  48.     $menu configure -transient 0
  49.  
  50.     # Pick a title for the new menu by looking at the parent of the
  51.     # original: if the parent is a menu, then use the text of the active
  52.     # entry.  If it's a menubutton then use its text.
  53.  
  54.     set parent [winfo parent $w]
  55.     switch [winfo class $parent] {
  56.     Menubutton {
  57.         wm title $menu [$parent cget -text]
  58.     }
  59.     Menu {
  60.         wm title $menu [$parent entrycget active -label]
  61.     }
  62.     }
  63.  
  64.     $menu configure -tearoff 0
  65.     $menu post [winfo x $w] [winfo y $w]
  66.  
  67.     # Set tkPriv(focus) on entry:  otherwise the focus will get lost
  68.     # after keyboard invocation of a sub-menu (it will stay on the
  69.     # submenu).
  70.  
  71.     bind $menu <Enter> {
  72.     set tkPriv(focus) %W
  73.     }
  74.  
  75.     # If there is a -tearoffcommand option for the menu, invoke it
  76.     # now.
  77.  
  78.     set cmd [$w cget -tearoffcommand]
  79.     if {$cmd != ""} {
  80.     eval $cmd $w $menu
  81.     }
  82. }
  83.  
  84. # tkMenuDup --
  85. # Given a menu (hierarchy), create a duplicate menu (hierarchy)
  86. # in a given window.
  87. #
  88. # Arguments:
  89. # src -            Source window.  Must be a menu.  It and its
  90. #            menu descendants will be duplicated at dst.
  91. # dst -            Name to use for topmost menu in duplicate
  92. #            hierarchy.
  93.  
  94. proc tkMenuDup {src dst} {
  95.     set cmd "menu $dst"
  96.     foreach option [$src configure] {
  97.     if {[llength $option] == 2} {
  98.         continue
  99.     }
  100.     lappend cmd [lindex $option 0] [lindex $option 4]
  101.     }
  102.     eval $cmd
  103.     set last [$src index last]
  104.     if {$last == "none"} {
  105.     return
  106.     }
  107.     for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
  108.     set cmd "$dst add [$src type $i]"
  109.     foreach option [$src entryconfigure $i]  {
  110.         lappend cmd [lindex $option 0] [lindex $option 4]
  111.     }
  112.     eval $cmd
  113.     if {[$src type $i] == "cascade"} {
  114.         tkMenuDup [$src entrycget $i -menu] $dst.m$i
  115.         $dst entryconfigure $i -menu $dst.m$i
  116.     }
  117.     }
  118.  
  119.     # Duplicate the binding tags and bindings from the source menu.
  120.  
  121.     regsub -all . $src {\\&} quotedSrc
  122.     regsub -all . $dst {\\&} quotedDst
  123.     regsub -all $quotedSrc [bindtags $src] $dst x
  124.     bindtags $dst $x
  125.     foreach event [bind $src] {
  126.     regsub -all $quotedSrc [bind $src $event] $dst x
  127.     bind $dst $event $x
  128.     }
  129. }
  130.